perm filename INITST.LSP[SCH,LSP] blob
sn#688830 filedate 1982-11-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 -*-LISP-*- Constructs initial memory load for DEC20 SCHEME
C00005 00003
C00007 00004
C00010 00005
C00014 00006
C00017 00007
C00020 00008
C00024 00009
C00026 00010
C00029 00011
C00033 00012
C00037 00013
C00045 00014
C00048 00015
C00051 ENDMK
C⊗;
;;; -*-LISP-*- Constructs initial memory load for DEC20 SCHEME
(HERALD INITST "")
(EVAL-WHEN (COMPILE) (LOAD "SCM:UMACRO"))
(EVAL-WHEN (COMPILE) (LOAD "SCM:SMACRO"))
;;;; procedure importation system
;;; SETUP defines a set of initial procedures
(DEFUN-IMPORT IMPORT-LISP-PRIMITIVE (SPEC)
(COND ((SYMBOLP SPEC)
(SET-GLOBAL-VALUE SPEC (MAKE-SCHEME-PROCEDURE SPEC SPEC NIL)))
(T (SET-GLOBAL-VALUE (CAR SPEC)
(MAKE-SCHEME-PROCEDURE (CAR SPEC)
(CADR SPEC)
(IF (CDDR SPEC)
(CADDR SPEC)
NIL))))))
;;; allows a much more powerful system to be built.
(DEFUN-IMPORT GET-LISP-PROCEDURE (SPEC)
(COND ((SYMBOLP SPEC) (MAKE-SCHEME-PROCEDURE SPEC SPEC NIL))
(T (MAKE-SCHEME-PROCEDURE (CAR SPEC)
(CADR SPEC)
(IF (CDDR SPEC)
(CADDR SPEC)
NIL)))))
#M
(DEFUN MAKE-SCHEME-PROCEDURE (SCHEME-NAME LISP-NAME SPECIAL-TYPE)
(LET ((F (GETL LISP-NAME '(SUBR LSUBR EXPR))))
(COND ((NULL F)
(SCH-ERROR "Undefined import" LISP-NAME 'FAIL-ACT)))
(MAKE-PRIMITIVE-PROCEDURE (OR SPECIAL-TYPE (CAR F))
(CADR F)
(ARGS LISP-NAME)
SCHEME-NAME)))
#Q
(DEFUN MAKE-SCHEME-PROCEDURE (SCHEME-NAME LISP-NAME)
(COND ((NOT (FBOUNDP LISP-NAME))
(SCH-ERROR "Undefined import" LISP-NAME 'FAIL-ACT)))
(MAKE-PRIMITIVE-PROCEDURE 'SUBR ;class
(FSYMEVAL LISP-NAME) ;object
(LENGTH (ARGLIST LISP-NAME)) ;number of args
SCHEME-NAME));name [symbol]
(DEFVAR *NOPRINT* (LIST '*NOPRINT*))
(DEFVAR *scheme-source*
(caseq (status site)
(mc "scheme;")
(ee "<ls.development>")
(oz "<scheme.development>")))
;;;; the SCHEME run-time environment
;;; read-eval-print is defined in the SETUP.
(DEFUN SETUP ()
(MAPC 'IMPORT-LISP-PRIMITIVE *LISP-IMPORTS*)
(SET-GLOBAL-VALUE 'EVAL-NO-SYNTAX (MAKE-HUNK '*EVALUATOR* NIL))
;; The interrupts live here.
(SET-GLOBAL-VALUE 'SYSTEM-INTERRUPT-VECTOR (MAKE-HUNK-OF-SIZE 16.))
(BREAK "PROCEED to construct SCHEME environment")
(RUN (SYNTAX '(sequence
;;; Setup the "user package".
(define system-global-environment (the-environment))
(define user-initial-environment (make-environment)) ;never altered.
(define top-level-environment user-initial-environment) ;modified by
; goto-environment.
(define t 't)
;;; The following variables and procedures are used for controlling the read-eval-print
(define *noprint* (symeval '*noprint*)) ; To return a non-printing value
(define (goto-environment new-env)
(if (environment? new-env)
(sequence (set! top-level-environment new-env)
(visit-environment new-env) ; for everyone else
*noprint*)
"Bad environment"))
;;;; SCHEME-SYSTEM-PACKAGE
;;; This defines the driver as a (SCHEME) procedure.
(define scheme-system-package
(make-environment
(define-export visit-environment system-global-environment nil)
(define abort-to-nearest-driver nil)
(define abort-to-previous-driver nil)
(define abort-to-top-level-driver nil)
(define return-to-caller-of-driver nil)
(define the-read-eval-print-environment nil)
(define the-read-eval-print-level 0)
(define the-read-eval-print-messages nil)
;;; the read-eval-print loop is defined below
;;; History structure default dimensions:
(define-export max-subproblems system-global-environment 10.)
(define-export max-reductions system-global-environment 5.)
(define-export max-subexpressions system-global-environment 5.)
;;; System prompt
(define default-top-level-prompt "==> ")
(define-export (top-level-driver message) system-global-environment
(catch quit
(fluid-let ((abort-to-top-level-driver quit))
(read-eval-print top-level-environment
message
default-top-level-prompt)))
(top-level-driver "Quit!"))
;;; User read-eval-print facilities
(define-export (read-eval-print env message prompt) system-global-environment
(catch caller (read-eval-print-internal env message prompt caller)))
(define-export (error message irritant) system-global-environment
(check-and-save-history)
(internal-error message irritant))
(define-export (bkpt message irritant) system-global-environment
(check-and-save-history)
(internal-bkpt message irritant))
(define (internal-error message irritant)
(break-loop (cons "Error!" (merge-messages message irritant))
"Error-> "))
(define (internal-bkpt message irritant)
(break-loop (cons "Bkpt!" (merge-messages message irritant))
"Bkpt-> "))
(define (break-loop message prompt)
(define (break-loop-environment cont)
(let ((e (continuation-environment cont)))
(if (or (null? e) (eq? e 'no-environment-saved))
(sequence (print 'no-environment-saved) top-level-environment)
e)))
(catch caller
(read-eval-print-internal (break-loop-environment caller)
message
prompt
caller)))
(define (read-eval-print-internal env message prompt caller)
(define (rep-1 input)
(if (eq? input '≠p)
(caller nil)
(rep-2 (sequence
(setup-history max-subproblems
max-reductions
max-subexpressions)
(eval input env)))))
(define (rep-2 output)
(if (not (eq? output *noprint*)) (print output))
(fresh-line)
(newline)
(rep-1 (read prompt)))
(define (driver-loop message)
(let ((abort-message
(catch again
(fluid-let ((abort-to-nearest-driver again))
(set-interrupts-enabled 'T)
(apply display message)
(rep-2 *noprint*)))))
(driver-loop (list abort-message
"Returning to level"
the-read-eval-print-level))))
(fluid-let ((abort-to-previous-driver abort-to-nearest-driver)
(the-read-eval-print-level (1+ the-read-eval-print-level))
(the-read-eval-print-messages
(cons message the-read-eval-print-messages))
(return-to-caller-of-driver caller)
(visit-environment (lambda (new-env) (set! env new-env)))
(the-read-eval-print-environment (lambda () env)))
(driver-loop `(,@(if (atom? message) (list message) message)
"Level:" ,the-read-eval-print-level))))
(define (merge-messages possible-compound simple)
(append (if (atom? possible-compound)
(list possible-compound)
possible-compound)
(list simple)))
;;; Check-and-save-history in the place where it is so that there will
;;; be less garbage in the history structure.
(define check-and-save-history (get-lisp-procedure 'check-and-save-history))
(define merge-history (get-lisp-procedure 'merge-history))
;;;; INTERRUPT-SYSTEM-PACKAGE
(define interrupt-system-package
(make-environment
(define reshape-at-interrupt (get-lisp-procedure 'reshape-at-interrupt))
(define-export *message* system-global-environment nil)
(define-export *irritant* system-global-environment nil)
(define (default-error-handler interrupts-enabled interrupts-pending)
(reshape-at-interrupt '(error *message* *irritant*))
(internal-error *message* *irritant*))
(rplacx 1. system-interrupt-vector default-error-handler) ;Primitives
(rplacx 2. system-interrupt-vector default-error-handler) ;Execution
(define (default-↑B-handler interrupts-enabled interrupts-pending)
(reshape-at-interrupt '(bkpt *message* *irritant*))
(internal-bkpt *message* *irritant*))
(rplacx 3. system-interrupt-vector default-↑B-handler)
(define (default-↑B-handler interrupts-enabled interrupts-pending)
(reshape-at-interrupt '(bkpt "↑B" "interrupt"))
(internal-bkpt "↑B" "interrupt"))
(rplacx 4. system-interrupt-vector default-↑B-handler)
(define (default-↑G-handler interrupts-enabled interrupts-pending)
(abort-to-top-level-driver "Quit!"))
(rplacx 5. system-interrupt-vector default-↑G-handler)
(define (default-↑U-handler interrupts-enabled interrupts-pending)
(if abort-to-previous-driver
(abort-to-previous-driver "Up!")
(abort-to-nearest-driver "Already at top level!")))
(rplacx 6. system-interrupt-vector default-↑U-handler)
(define (default-↑X-handler interrupts-enabled interrupts-pending)
(abort-to-nearest-driver "Abort!"))
(rplacx 7. system-interrupt-vector default-↑X-handler)
)) ;end INTERRUPT-SYSTEM-PACKAGE
)) ;end SCHEME-SYSTEM-PACKAGE
;;;; TRANSPUT-PACKAGE
(define transput-package
(make-environment
(define si: system-global-environment) ;just kidding, folks!
;;; character I/O
(define-export tyi si: (get-lisp-procedure '(tyi tty-tyi)))
(define-export tyipeek si: (get-lisp-procedure 'tyipeek))
(define-export readch si: (get-lisp-procedure '(readch schreadch)))
(define-export peekch si: (get-lisp-procedure '(peekch schpeekch)))
(define-export tyo si: (get-lisp-procedure '(tyo schtyo)))
(define-export newline si: (get-lisp-procedure '(newline schterpri)))
(define-export fresh-line si: (get-lisp-procedure '(fresh-line schfresh-line)))
(define-export beep si: (get-lisp-procedure '(beep schbeep-at-user)))
(define-export char si: (get-lisp-procedure '(char ascii)))
(define-export ascii si: (get-lisp-procedure '(ascii schcvtn)))
;;; string hackers
(define-export implode si: (get-lisp-procedure '(implode sch-implode)))
(define-export explode si: (get-lisp-procedure '(explode schexplode)))
(define-export clear-screen si: (get-lisp-procedure 'clear-screen))
;;; functions used in implementing I/O histories.
(define (make-circular-list-of-size n)
(if (not (> n 0))
(sch-error "Must be non-negative integer -- MAKE-CIRCULAR-LIST-OF-SIZE"
n))
(let ((tail (cons nil '())))
(define (cons-loop i last)
(if (= i 0)
(sequence (set!-cdr tail last) last)
(cons-loop (-1+ i) (cons nil last))))
(cons-loop (-1+ n) tail)))
(define (copy-and-open-circular-list the-list)
(let ((tail (cdr the-list)))
(set!-cdr the-list '())
(let ((valret (reverse tail)))
(set!-cdr the-list tail)
valret)))
;;; s-expression I/O
(define primitive-read (get-lisp-procedure '(primitive-read tty-read)))
(define-export readline si: (get-lisp-procedure '(readline tty-readline)))
(define *reader-history* '())
(define-export (read . args) si:
(let ((inval (apply primitive-read args)))
(set! *reader-history* (cdr *reader-history*))
(set!-car *reader-history* inval)
inval))
(define-export (setup-reader-history n) si:
(set! *reader-history* (make-circular-list-of-size n))
'done)
(define-export (get-reader-history) si: (copy-and-open-circular-list *reader-history*))
(setup-reader-history 5.)
;;; Printer control defaults:
(define-export *check-circularity* system-global-environment t)
(define-export *print-depth* system-global-environment nil)
(define-export *print-breadth* system-global-environment nil)
;;; Printer primitives:
(define schprint (get-lisp-procedure 'schprint))
(define schpp (get-lisp-procedure 'schpp))
(define-export display si: (get-lisp-procedure 'display))
(define-export princ si: (get-lisp-procedure 'schprinc))
(define-export prin1 si: (get-lisp-procedure 'schprin1))
(define *printer-history* '())
(define (print-recorder form)
(set! *printer-history* (cdr *printer-history*))
(set!-car *printer-history* form))
(define-export (setup-printer-history n) si:
(set! *printer-history* (make-circular-list-of-size n))
'done)
(define-export (get-printer-history) si:
(copy-and-open-circular-list *printer-history*))
;;; Convenient functions to get last thing printed and last thing typed
(define-export (%out) si: (car *printer-history*))
;;; Can't be (car *printer-history*) since it would be the input which
;;;caused the call to %in
(define-export (%in) si: (cadr (get-reader-history)))
(setup-printer-history 10.)
(define (print-wrapper printer)
(lambda (form)
(print-recorder form)
(printer form)))
;;; The only functions which store their argument are:
;;;(the reason is that princ is called on the prompt, and display is an lsubr).
(define-export print si: (print-wrapper schprint))
(define-export pp si: (print-wrapper schpp))
;;; various special printers.
(define-export tofu si: (get-lisp-procedure '(tofu sch-tofu)))
(define-export photo si: (get-lisp-procedure '(photo sch-photo)))
;;; file I/O -- students shouldn't be able to get at this.
(define terminal-output (symeval '*outstream*))
(define terminal-input (symeval 'tyi))
(define file-open (get-lisp-procedure '(file-open open)))
(define file-close (get-lisp-procedure '(file-close close)))
(define file-read (get-lisp-procedure '(file-read sch-file-read)))
(define file-tyo (get-lisp-procedure '(file-tyo sch-tyo)))
(define file-newline (get-lisp-procedure '(file-newline sch-terpri)))
(define (file-print-wrapper printer)
(lambda (form filestream)
(printer form filestream)))
(define file-princ
(file-print-wrapper (get-lisp-procedure '(file-princ schprinc))))
(define file-print
(file-print-wrapper (get-lisp-procedure '(file-print schprint))))
(define file-pp
(file-print-wrapper (get-lisp-procedure '(file-pp schpp))))
)) ;end of TRANSPUT-PACKAGE
;;;; SYSTEM-LOADER-PACKAGE
(define system-loader-package
(make-environment
(define file-read (access file-read transput-package)) ;get the file operations.
(define open (access file-open transput-package))
(define close (access file-close transput-package))
(define probef (get-lisp-procedure 'probef))
(define mergef (get-lisp-procedure 'mergef))
(define load-parse (get-lisp-procedure 'sch-load-parse))
;;; Loader for SCHEME in Maclisp
#M
(define-export (load . args) system-global-environment
; (load file-name [print-flag])
(let ((filename (load-parse (car args)))
(print-flag (cadr args)))
(let ((name (probef filename)))
(cond ((null? name)
;; no file there at at all
(error "File not found -- LOAD" filename))
(else
(let ((file (open name '(dsk in)))
(eof (list 'eof))
(env top-level-environment)) ;Shouldn't it be the rep env?
;There is no way to load into a package otherwise---jinx
(define (read-loop)
(let ((input (file-read file eof)))
(cond ((eq? input eof)
(close file)
*noprint*)
(print-flag
(print (eval input env))
(read-loop))
(else
(eval input env)
(read-loop)))))
(read-loop)))))))
;;; Scheme loader for Lisp Machine:
;;; Much of the following code has been appropriated from AI:LISPM;QFASL
;;; with some modifications for Scheme.
#Q
(define-export load system-global-environment
(let ((fs:load-pathname-defaults (lisp-eval 'fs:load-pathname-defaults)))
(define (load filename) ;changed only to get rid of & keywords
(let ((pkg)
(nonexistent-ok-flag)
(dont-set-default-p)
(pathname)
(stream))
;; there should be an unwind-protect around the following SEQUENCE
(sequence
(set! pathname (fs:parse-pathname filename nil fs:load-pathname-defaults))
;; if no file type or version (no its fn2) was specified, first look for
;; the qfasl.
(or (and (memq (funcall pathname ':type) '(nil :unspecific))
(memq (funcall pathname ':version) '(nil :unspecific))
(not (stringp (set! stream (open (fs:merge-pathname-defaults
pathname
fs:load-pathname-defaults
"qfasl")
'(:read :fixnum :noerror))))))
(set! stream (open (fs:merge-pathname-defaults pathname
fs:load-pathname-defaults "lisp")
(if nonexistent-ok-flag '(:read :fixnum :noerror)
'(:read :fixnum)))))
(cond ((stringp stream) nonexistent-ok-flag)
(else ;; we now have the file open, but its pathname could be completely
;; different if an error occurred and a new pathname was supplied.
(set! pathname (funcall stream ':pathname))
(or dont-set-default-p
(fs:set-default-pathname pathname fs:load-pathname-defaults))
;; if the file we have open in binary mode is a qfasl file, fasload it.
;; otherwise close it, re-open it in text mode, and readfile it.
(cond ((funcall stream ':qfaslp)
(fasload-internal stream pkg nil))
(else (close stream)
(set! stream (open pathname '(:read)))
(readfile-internal stream pkg nil))))))
;; cleanup form
(and stream (not (stringp stream)) (close stream))))
(define (readfile-internal standard-input pkg no-msg-p)
(let ((file-id)
(pathname)
(generic-pathname)
(package)
(fdefine-file-pathname))
(set! file-id (funcall standard-input ':info))
(set! pathname (funcall standard-input ':pathname))
(set! generic-pathname (funcall pathname ':generic-pathname))
(set! fdefine-file-pathname generic-pathname)
(fs:file-read-property-list generic-pathname standard-input)
;; enter appropriate environment for the file
; (multiple-value-bind (vars vals) (fs:file-property-bindings generic-pathname)
; (progv vars vals
;; if package overridden, do so. package is bound in any case.
; (cond (pkg (set! package (pkg-find-package pkg)))
; (no-msg-p) ;and tell user what it was unless told not to
; (t (format t "}&loading file }a into package }a}%" pathname package)))
(readforms standard-input '(()))
(system-internals:set-file-loaded-id pathname file-id package)
pathname));))
(define (readforms standard-input eof) ;read the forms with scheme's eval
(let ((form)
(env top-level-environment)) ;into top-level-environment
(cond
((eq? (set! form (read standard-input eof)) eof))
(else (eval form env)
(readforms standard-input eof)))))
load)) ;end of define
;;;; the bootstrap hook
;;; Once read-eval-print is defined, we can get to it with this.
(define *scheme-source* (symeval '*scheme-source*))
(define-export (setup-driver-loop) system-global-environment
#M(maclisp-setup)
(dynamic-wind ;guarantees startup
nil
(let ((f ((get-lisp-procedure 'sch-fix-file)))
(emacs-zap (lisp-eval '(probef *EDITOR-COMM-FILE*)))
(messag (probef (mergef *scheme-source* '(usrmsg scm))))
(init (probef '(Init scm))))
(cond (f
(PRINT (LIST 'LOADING f))
(load f)
(PRINT '(DONE LOADING))))
(if emacs-zap
(sequence
(dynamic-wind nil ;guarantees closing!
(load emacs-zap 'T)
(deletef emacs-zap))
(display "Emacs buffer loaded")))
(if messag (load messag))
(if init (load init)))
(top-level-driver (list "SCHEME system made on" SCHEME-VERSION
"with MacLISP:" LISP-VERSION))))
)) ;end SYSTEM-LOADER-PACKAGE
;;;; ADVICE-PACKAGE
;;; **** NOTE: there is still one bug, which should be fixed. when an advised
;;; function is redefined, it should retain its advice. this should likely be
;;; the responsibility of LSET. since this is a fairly delicate hack, it is not
;;; implemented; also, there may be some disagreement if it is the right thing.
;;; **** NOTE: the advice package can be redone much better using a flag in
;;; the procedure object and a FLAGS rack. Super stepping, protections, and
;;; specifications can all be provided when a FLAGS rack, checked on CONTINUE,
;;; is added.
(define advice-package
(make-environment
(define check-and-save-history
(access check-and-save-history scheme-system-package))
(define merge-history
(access merge-history scheme-system-package))
(define-export *advised-procedures* system-global-environment nil)
(define primitive-advise
(get-lisp-procedure '(primitive-advise sch-advise)))
(define-export (advise proc advice) system-global-environment
(primitive-advise proc advice advice 'wrap))
(define-export (advise-entry proc advice) system-global-environment
(primitive-advise proc
(lambda (proc args env)
(check-and-save-history)
(advice proc args env)
(merge-history 0)
(apply proc args))
advice
'entry))
(define-export (advise-exit proc advice) system-global-environment
(primitive-advise proc
(lambda (proc args env)
(let ((result (apply proc args)))
(check-and-save-history)
(let ((nresult (advice proc args result env)))
(merge-history 0)
nresult)))
advice
'exit))
(define primitive-unadvise-type
(get-lisp-procedure 'unadvise-particular-type))
(define primitive-unadvise-choose
(get-lisp-procedure 'unadvise-particular-advice))
(define-export unadvise system-global-environment
(get-lisp-procedure '(unadvise unadvise-completely)))
(define-export advice system-global-environment
(get-lisp-procedure 'advice))
(define-export (unadvise-entry proc) system-global-environment
(primitive-unadvise-type proc 'entry))
(define-export (unadvise-exit proc) system-global-environment
(primitive-unadvise-type proc 'exit))
(define (trace-entry-advice proc args env)
(newline)
(princ "[ Entering ")
(princ (cons (procedure-name proc)
args))
(princ " ]"))
(define-export (trace-entry proc) system-global-environment
(advise-entry proc trace-entry-advice))
(define (simple-untrace-entry proc)
(primitive-unadvise-choose proc trace-entry-advice))
(define-export (untrace-entry . procs) system-global-environment
(mapcar simple-untrace-entry
(if (null? procs)
*advised-procedures*
procs))
*advised-procedures*)
(define (trace-exit-advice proc args result env)
(newline) (princ "[ ") (princ result) (princ " <== ")
(princ (cons (procedure-name proc) args))
(princ " ]")
result)
(define-export (trace-exit proc) system-global-environment
(advise-exit proc trace-exit-advice))
(define (simple-untrace-exit proc)
(primitive-unadvise-choose proc trace-exit-advice))
(define-export (untrace-exit . procs) system-global-environment
(mapcar simple-untrace-exit
(if (null? procs)
*advised-procedures*
procs))
*advised-procedures*)
(define-export (trace proc) system-global-environment
(trace-entry proc)
(trace-exit proc))
(define-export (untrace . procs) system-global-environment
(apply untrace-entry procs)
(apply untrace-exit procs))
(define-export *proc* system-global-environment nil)
(define-export *args* system-global-environment nil)
(define-export *result* system-global-environment nil)
(define (break-entry-advice proc args env)
(newline)
(princ "[ Entering ")
(princ (cons proc args))
(princ " ]")
(fluid-let ((*proc* proc)
(*args* args))
(read-eval-print
env
"Bkpt! Entering (*proc* . *args*) "
"Bkpt-> ")
t))
(define-export (break-entry proc) system-global-environment
(advise-entry proc break-entry-advice))
(define (break-exit-advice proc args result env)
(newline) (princ "[ ") (princ result) (princ " <== ")
(princ (cons proc args))
(princ " ]")
(fluid-let ((*proc* proc)
(*args* args)
(*result* result))
(read-eval-print
env
"Bkpt! Exiting *result* <== (*proc* . *args*)"
"Bkpt-> ")
*result*))
(define-export (break-exit proc) system-global-environment
(advise-exit proc break-exit-advice))
(define-export (break proc) system-global-environment
(break-entry proc)
(break-exit proc))))
;end ADVICE-PACKAGE
;;;; randomness
#Q(define (cxr n h) (aref h n))
#Q(define (rplacx n h x) (aset x h n))
#Q(define (hunkp h) (arrayp h))
#M
(define (edit)
(PRINT '(=> EMACS))
(enter-emacs)
(IF *LEDIT-FILE-IN*
(dynamic-wind nil ;guarantees closing!
(load *ledit-file-in* 'T)
(deletef *ledit-file-in*)))
(PRINT '(SCHEME <=))
*noprint*)
#Q(define (edit)
(let ((list-of-forms editor))
(cond ((null list-of-forms) (newline) (princ '|Nothing to evaluate.|))
(else (mapcar (lambda (form) (eval form top-level-environment)) list-of-forms)
(newline) (princ '|Ok. Forms evaluated.|)))))
;;; Important definitions:
(define (every-pair p l)
(define (elp last l)
(cond ((null? l) t)
((p last (car l)) (elp (car l) (cdr l)))
(t nil)))
(elp (car l) (cdr l)))
(define (eval exp env)
(eval-no-syntax (syntax exp) env))
(define (mapc f l)
(if (null? l) nil
(sequence (f (car l))
(mapc f (cdr l)))))
(define (mapcan f l)
(if (null? l) nil
(conc! (f (car l)) (mapcan f (cdr l)))))
(define (mapcar f l)
(if (null? l) nil
(cons (f (car l)) (mapcar f (cdr l)))))
;;; For streams:
(define head car)
(define tail cdr)
(define empty-stream? null?)
(define (the-empty-stream) NIL)
;;;; Array Objects
;;; The following is an iterator which will enumerate all points
;;; in an array, given the maximal point.
(define (next-point-array point max-point)
(cond ((null? point) '())
((< (car point) (car max-point))
(cons (1+ (car point)) (cdr point)))
(else
(cons 0
(next-point-array (cdr point)
(cdr max-point))))))
(define (initialize-array array dimensions init-proc)
(let ((max-point (mapcar -1+ dimensions)))
(define (loop point)
(set!-array array point (init-proc point))
(cond ((equal? max-point point)
'done)
(else
(loop (next-point-array point max-point)))))
(loop (next-point-array max-point max-point))))
;;; Bowbeer's system
(define (make-array dimensions init-proc)
(let ((array (make-array-object dimensions init-proc)))
(if init-proc (initialize-array array dimensions init-proc))
array))
;;; Traditional system
(define (amake . l)
(make-array (cdr l)
(lambda (x)
(apply (car l) x))))
(define (aref . l)
(access-array (car l) (cdr l)))
(define (aset! . l)
(set!-array (cadr l) (cddr l) (car l)))
(load "scm:debug")
(setup-driver-loop) ; Defined in system-loader-package
) ; End of SCHEME-SYSTEM definitions
)))